Disc to the Future 2/Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin/UNIX/PASCAL/PTOC/PTC_P.2

Text File | 1992-11-23 | 53KB | 2,502 lines

            if sp^.lt = lforwlab then
                sp^.lt := llabel
            else
                error(emuldeflab);
            end;
        oldlbl := tp
    end;

    (*    Parse declaration and statement-body for prog/subs.    *)
    procedure pbody(tp : treeptr);

    var    tq    : treeptr;

    begin
        statlvl := statlvl + 1;
        if currsym.st = slabel then
            begin
            tp^.tsublab := plabel;
            linkup(tp, tp^.tsublab)
            end
        else
            tp^.tsublab := nil;
        if currsym.st = sconst then
            begin
            tp^.tsubconst := pconst;
            linkup(tp, tp^.tsubconst)
            end
        else
            tp^.tsubconst := nil;
        if currsym.st = stype then
            begin
            tp^.tsubtype := ptype;
            linkup(tp, tp^.tsubtype)
            end
        else
            tp^.tsubtype := nil;
        if currsym.st = svar then
            begin
            tp^.tsubvar := pvar;
            linkup(tp, tp^.tsubvar)
            end
        else
            tp^.tsubvar := nil;
        tp^.tsubsub := nil;
        tq := nil;
        while (currsym.st = sproc) or (currsym.st = sfunc) do
            begin
            if tq = nil then
                begin
                tq := psubs;
                tp^.tsubsub := tq
                end
            else begin
                tq^.tnext := psubs;
                tq := tq^.tnext
                 end
            end;
        linkup(tp, tp^.tsubsub);
        checksymbol([sbegin, seof]);
        if currsym.st = sbegin then
            begin
            tp^.tsubstmt := pbegin(false);
            linkup(tp, tp^.tsubstmt)
            end;
        statlvl := statlvl - 1
    end;

    (*    Parse program-declaration.                *)
    function pprogram : treeptr;

    var    tp    : treeptr;

        (*    Parse a program parameter id-list.        *)
        function pprmlist : treeptr;

        label    999;

        var    tp,
            tq    : treeptr;
            din,
            dut    : idptr;

        begin
            tp := nil;
            din := deftab[dinput]^.tidl^.tsym^.lid;
            dut := deftab[doutput]^.tidl^.tsym^.lid;
            while (currsym.vid = din) or (currsym.vid = dut) do
                begin
                (* ignore input/output as parameters so that
                   they will be bound to stdin/stdout unless
                   declared as variables *)
                if currsym.vid = din then
                    defnams[dinput]^.lused := true
                else
                    defnams[doutput]^.lused := true;
                nextsymbol([scomma, srpar]);
                if currsym.st = srpar then
                    goto 999;
                nextsymbol([sid])
                end;
            tq := newid(currsym.vid);
            tq^.tsym^.lt := lpointer;
            tp := tq;
            nextsymbol([scomma, srpar]);
            while currsym.st = scomma do
                begin
                nextsymbol([sid]);
                if currsym.vid = din then
                    defnams[dinput]^.lused := true
                else if currsym.vid = dut then
                    defnams[doutput]^.lused := true
                else begin
                    tq^.tnext := newid(currsym.vid);
                    tq := tq^.tnext;
                    tq^.tsym^.lt := lpointer;
                     end;
                nextsymbol([scomma, srpar])
                end;
        999:
            pprmlist := tp
        end;

    begin    (* pprogram *)
        enterscope(nil);
        tp := mknode(npgm);
        nextsymbol([sid]);
        tp^.tstat := statlvl;
        tp^.tsubid := mknode(nid);
        tp^.tsubid^.tup := tp;
        tp^.tsubid^.tsym := mksym(lidentifier);
        tp^.tsubid^.tsym^.lid := currsym.vid;
        tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid;
        linkup(tp, tp^.tsubid);
        nextsymbol([slpar, ssemic]);
        if currsym.st = slpar then
            begin
            nextsymbol([sid]);
            tp^.tsubpar := pprmlist;
            linkup(tp, tp^.tsubpar);
            nextsymbol([ssemic])
            end
        else
            tp^.tsubpar := nil;
        nextsymbol([slabel, sconst, stype, svar,
                        sproc, sfunc, sbegin]);
        pbody(tp);
        checksymbol([sdot]);
        tp^.tscope := currscope;
        leavescope;
        pprogram := tp
    end;    (* pprogram *)

    (*    Parse a module.                *)
    function pmodule : treeptr;

    var    tp    : treeptr;

    begin    (* pmodule *)
        enterscope(nil);
        tp := mknode(npgm);
        tp^.tstat := statlvl;
        tp^.tsubid := nil;
        tp^.tsubpar := nil;
        pbody(tp);
        checksymbol([ssemic]);
        tp^.tscope := currscope;
        leavescope;
        pmodule := tp
    end;    (* pmodule *)


    (*    Parse label-clause.                    *)
    function plabel;

    var    tp,
        tq    : treeptr;

    begin
        tq := nil;
        repeat
            nextsymbol([sinteger]);
            if tq = nil then
                begin
                tq := newlbl;
                tp := tq
                end
            else begin
                tq^.tnext := newlbl;
                tq := tq^.tnext;
                 end;
            nextsymbol([scomma, ssemic])
        until    currsym.st = ssemic;
        nextsymbol([sconst, stype, svar, sbegin, sproc, sfunc]);
        plabel := tp
    end;

    (*    Parse an id-list.                    *)
    function pidlist;

    var    tp,
        tq    : treeptr;

    begin
        tq := newid(currsym.vid);
        tq^.tsym^.lt := l;
        tp := tq;
        nextsymbol([scomma, scolon, seq, srpar]);
        while currsym.st = scomma do
            begin
            nextsymbol([sid]);
            tq^.tnext := newid(currsym.vid);
            tq := tq^.tnext;
            tq^.tsym^.lt := l;
            nextsymbol([scomma, scolon, seq, srpar])
            end;
        pidlist := tp
    end;

    (*    Parse const-clause.                    *)
    function pconst;

    var    tp,
        tq    : treeptr;

    begin
        tq := nil;
        nextsymbol([sid]);
        repeat
            if tq = nil then
                begin
                tq := mknode(nconst);
                tq^.tattr := anone;
                tp := tq
                end
            else begin
                tq^.tnext := mknode(nconst);
                tq := tq^.tnext;
                tq^.tattr := anone
                 end;
            tq^.tidl := pidlist(lidentifier);
            checksymbol([seq]);
            nextsymbol([sid, schar, sstring, sinteger, sreal,
                        splus, sminus]);
            tq^.tbind := pconstant(true);
            nextsymbol([ssemic]);
            nextsymbol([sid, stype, svar, sbegin,
                            sfunc, sproc, seof])
        until    currsym.st <> sid;
        pconst := tp
    end;

    (*    Parse a declared constant or a case-statment const.    *)
    function pconstant;

    var    tp,
        tq    : treeptr;
        neg    : boolean;

    begin
        neg := currsym.st = sminus;
        if currsym.st in [splus, sminus] then
            if realok then
                nextsymbol([sid, sinteger, sreal])
            else
                nextsymbol([sid, sinteger]);
        if currsym.st = sid then
            tp := oldid(currsym.vid, lidentifier)
        else
            tp := mklit;
        if neg then
            begin
            tq := mknode(numinus);
            tq^.texps := tp;
            tp := tq
             end;
        pconstant := tp
    end;

    (*    Parse a record (or record-variant) declaration.        *)
    (*    Cs is the expected closing symbol, dp the scope.    *)
    function precord;

    label    999;

    var    tp,
        tq,
        tl,
        tv    : treeptr;
        tsym    : lexsym;

    begin
        tp := mknode(nrecord);
        tp^.tflist := nil;
        tp^.tvlist := nil;
        tp^.tuid := nil;
        tp^.trscope := nil;
        if cs = send then
            begin
            enterscope(dp);
            dp := currscope
            end;
        nextsymbol([sid, scase] + [cs]);
        tq := nil;
        while currsym.st = sid do
            begin
            if tq = nil then
                begin
                tq := mknode(nfield);
                tq^.tattr := anone;
                tp^.tflist := tq
                end
            else begin
                tq^.tnext := mknode(nfield);
                tq := tq^.tnext;
                tq^.tattr := anone
                 end;
            tq^.tidl := pidlist(lfield);
            checksymbol([scolon]);
            leavescope;
            tq^.tbind := ptypedef;
            enterscope(dp);
            if currsym.st = ssemic then
                nextsymbol([sid, scase] + [cs])
            end;
        if currsym.st = scase then
            begin
            nextsymbol([sid]);
            tsym := currsym;
            nextsymbol([scolon, sof]);
            if currsym.st = scolon then
                begin
                tv := newid(tsym.vid);
                if tq = nil then
                    begin
                    tq := mknode(nfield);
                    tp^.tflist := tq
                    end
                else begin
                    tq^.tnext := mknode(nfield);
                    tq := tq^.tnext
                     end;
                tq^.tidl := tv;
                tv^.tsym^.lt := lfield;
                nextsymbol([sid]);
                leavescope;
                tq^.tbind := oldid(currsym.vid, lidentifier);
                enterscope(dp);
                nextsymbol([sof])
                end;
            tq := nil;
            repeat
                tv := nil;
                repeat
                    nextsymbol([sid, sinteger, schar, splus,
                             sminus] + [cs]);
                    if currsym.st = cs then
                        goto 999;
                    if tv = nil then
                        begin
                        tv := pconstant(false);
                        tl := tv
                        end
                    else begin
                        tv^.tnext := pconstant(false);
                        tv := tv^.tnext
                         end;
                    nextsymbol([scolon, scomma])
                until currsym.st = scolon;
                nextsymbol([slpar]);
                if tq = nil then
                    begin
                    tq := mknode(nvariant);
                    tp^.tvlist := tq;
                    end
                else begin
                    tq^.tnext := mknode(nvariant);
                    tq := tq^.tnext;
                     end;
                tq^.tselct := tl;
                tq^.tvrnt := precord(srpar, dp)
            until    currsym.st = cs
            end;
    999:
        if cs = send then
            begin
            tp^.trscope := dp;
            leavescope
            end;
        nextsymbol([ssemic, send, srpar]);
        (* currsym is the symbol following record end/rpar,
            (usually semicolon, sometimes enclosing end/rpar) *)
        precord := tp
    end;

    function ptypedef;

    var    tp,
        tq    : treeptr;
        st    : symtyp;
        ss    : symset;

    begin
        nextsymbol([sid, slpar, sarrow, sinteger, schar, splus, sminus,
                spacked, sarray, srecord, sfile, sset]);

        (* the "packed" keyword is completely ignored *)
        if currsym.st = spacked then
            nextsymbol([sarray, srecord, sfile, sset]);

        ss := [ssemic, send, srpar, scomma, srbrack];
        case currsym.st of
          splus,
          sminus,
          schar,
          sinteger,
          sid:
            begin
            st := currsym.st;
            tp := pconstant(false);
            if st = sid then
                nextsymbol([sdotdot] + ss)
            else
                nextsymbol([sdotdot]);
            if currsym.st = sdotdot then
                begin
                nextsymbol([sid, sinteger, schar,
                                splus, sminus]);
                tq := mknode(nsubrange);
                tq^.tlo := tp;
                tq^.thi := pconstant(false);
                tp := tq;
                nextsymbol(ss)
                end
            end;
          slpar:
            begin
            tp := mknode(nscalar);
            nextsymbol([sid]);
            tp^.tscalid := pidlist(lidentifier);
            checksymbol([srpar]);
            nextsymbol(ss)
            end;
          sarrow:
            begin
            tp := mknode(nptr);
            nextsymbol([sid]);
            tp^.tptrid := oldid(currsym.vid, lpointer);
            tp^.tptrflag := false;
            nextsymbol([ssemic, send, srpar])
            end;
          sarray:
            begin
            nextsymbol([slbrack]);
            tp := mknode(narray);
            tp^.taindx := ptypedef;    (* parse subrange ...    *)
            tq := tp;
            while currsym.st = scomma do
                begin
                (* expand:   array [ A , B ] of X
                   to:   array [ A ] of array [ B ] of X   *)
                tq^.taelem := mknode(narray);
                tq := tq^.taelem;
                tq^.taindx := ptypedef    (* ... again    *)
                end;
            checksymbol([srbrack]);
            nextsymbol([sof]);
            tq^.taelem := ptypedef
            end;
          srecord:
            tp := precord(send, nil);
          sfile,
          sset:
            begin
            if currsym.st = sfile then
                tp := mknode(nfileof)
            else begin
                tp := mknode(nsetof);
                usesets := true
                 end;
            nextsymbol([sof]);
            tp^.tof := ptypedef
            end
        end;
        (* at this point "currsym" holds the symbol following the type
           (usually semicolon, sometimes the following end/rpar) *)
        ptypedef := tp
    end;

    (*    Parse type-clause.                    *)
    function ptype;

    var    tp,
        tq    : treeptr;

    begin
        tq := nil;
        nextsymbol([sid]);
        repeat
            if tq = nil then
                begin
                tq := mknode(ntype);
                tq^.tattr := anone;
                tp := tq
                end
            else begin
                tq^.tnext := mknode(ntype);
                tq := tq^.tnext;
                tq^.tattr := anone
                 end;
            tq^.tidl := pidlist(lidentifier);
            checksymbol([seq]);
            tq^.tbind := ptypedef;
            nextsymbol([sid, svar, sbegin, sfunc, sproc, seof])
        until    currsym.st <> sid;
        ptype := tp;
    end;

    (*    Parse var-clause.                    *)
    function pvar;

    var    ti,
        tp,
        tq    : treeptr;

    begin
        tq := nil;
        nextsymbol([sid]);
        repeat
            if tq = nil then
                begin
                tq := mknode(nvar);
                tq^.tattr := anone;
                tp := tq
                end
            else begin
                tq^.tnext := mknode(nvar);
                tq := tq^.tnext;
                tq^.tattr := anone
                 end;

            ti := newid(currsym.vid);
            tq^.tidl := ti;
            nextsymbol([scomma, scolon]);
            while currsym.st = scomma do
                begin
                nextsymbol([sid]);
                ti^.tnext := newid(currsym.vid);
                ti := ti^.tnext;
                nextsymbol([scomma, scolon])
                end;

            tq^.tbind := ptypedef;
            nextsymbol([sid, sbegin, sfunc, sproc, seof])
        until    currsym.st <> sid;
        pvar := tp
    end;

    (*    Parse subroutine-declaration.                *)
    function psubs;

    var    tp,            (* return value        *)
        tv, tq    : treeptr;    (* temporary        *)
        func    : boolean;    (* true for functions    *)
        colsem    : symtyp;    (* colon/semicolon    *)

    begin
        (* parsing function or procedure *)
        func := currsym.st = sfunc;
        if func then
            colsem := scolon
        else
            colsem := ssemic;

        (* parse id, it may already be forward declared *)
        nextsymbol([sid]);
        tq := newid(currsym.vid);
        if tq^.tup = nil then
           begin
            enterscope(nil);
            (* id wasn't previously declared, params possible *)
            if func then
                tp := mknode(nfunc)
            else
                tp := mknode(nproc);
            tp^.tstat := statlvl;
            tp^.tsubid := tq;
            linkup(tp, tq);
            nextsymbol([slpar, colsem]);
            if currsym.st = slpar then
                begin
                tp^.tsubpar := psubpar;
                linkup(tp, tp^.tsubpar);
                nextsymbol([colsem])
                end
            else
                tp^.tsubpar := nil;
            if func then
                begin
                (* parse function type *)
                nextsymbol([sid]);
                tp^.tfuntyp := oldid(currsym.vid, lidentifier);
                nextsymbol([ssemic])
                end
            else
                tp^.tfuntyp := mknode(nempty);
            linkup(tp, tp^.tfuntyp);
            nextsymbol([sextern, sforward,
                    slabel, sconst, stype, svar,
                            sproc, sfunc, sbegin]);
           end
        else begin
            (* id was forward declared =>
                pick up declarations from parameterlist *)
            enterscope(tq^.tup^.tscope);
            if func then
                tp := mknode(nfunc)
            else
                tp := mknode(nproc);
            tp^.tfuntyp := tq^.tup^.tfuntyp;
            (* steal id and params from forward decl *)
            tv := tq^.tup^.tsubpar;
            tp^.tsubpar := tv;
            while tv <> nil do
                begin
                tv^.tup := tp;
                tv := tv^.tnext
                end;
            tp^.tsubid := tq;
            tq^.tup := tp;
            (* id was forward declared =>
                no params, no function type, no forward *)
            nextsymbol([ssemic]);
            nextsymbol([slabel, sconst, stype, svar,
                            sproc, sfunc, sbegin]);
             end;
        if currsym.st in [sforward, sextern] then
            begin
            tp^.tsubid^.tsym^.lt := lforward;
            nextsymbol([ssemic]);
            tp^.tsublab := nil;
            tp^.tsubconst := nil;
            tp^.tsubtype := nil;
            tp^.tsubvar := nil;
            tp^.tsubsub := nil;
            tp^.tsubstmt := nil
            end
        else
            pbody(tp);
        nextsymbol([sproc, sfunc, sbegin, seof]);
        tp^.tscope := currscope;
        leavescope;
        psubs := tp
    end;

    (*    Parse a conformant array index type.            *)
    function pconfsub : treeptr;

    var    tp    : treeptr;

    begin
        tp := mknode(nsubrange);
        nextsymbol([sid]);
        tp^.tlo := newid(currsym.vid);
        nextsymbol([sdotdot]);
        nextsymbol([sid]);
        tp^.thi := newid(currsym.vid);
        nextsymbol([scolon]);
        pconfsub := tp
    end;

    (*    Parse a conformant array-declaration.            *)
    function pconform : treeptr;

    var    tp, tq    : treeptr;

    begin
        nextsymbol([slbrack]);
        tp := mknode(nconfarr);
        tp^.tcuid := mkvariable('S');
        tp^.tcindx := pconfsub;    (* parse subrange ...    *)
        nextsymbol([sid]);
        tp^.tindtyp := oldid(currsym.vid, lidentifier);
        nextsymbol([ssemic, srbrack]);
        tq := tp;
        while currsym.st = ssemic do
            begin
            error(econfconf); (* what size does tp have *)

            (* expand:   array [ A ; B ] of X
               to:   array [ A ] of array [ B ] of X   *)
            tq^.tcelem := mknode(nconfarr);
            tq := tq^.tcelem;
            tq^.tcindx := pconfsub;    (* ... again    *)
            nextsymbol([sid]);
            tq^.tindtyp := oldid(currsym.vid, lidentifier);
            nextsymbol([ssemic, srbrack])
            end;
        nextsymbol([sof]);
        nextsymbol([sid, sarray]);
        case currsym.st of
          sid:
            tq^.tcelem := oldid(currsym.vid, lidentifier);
          sarray:
            begin
            error(econfconf); (* what size does tp have *)

            tq^.tcelem := pconform
            end;
        end;(* case *)
        pconform := tp
    end;

    (*    Parse subroutine parameter list.            *)
    function psubpar;

    var    tp,
        tq    : treeptr;
        nt    : treetyp;

    begin
        tq := nil;
        repeat
            nextsymbol([sid, svar, sfunc, sproc]);
            case currsym.st of
              sid:
                nt := nvalpar;
              svar:
                nt := nvarpar;
              sfunc:
                nt := nparfunc;
              sproc:
                nt := nparproc;
            end;
            if nt <> nvalpar then
                nextsymbol([sid]);
            if tq = nil then
                begin
                tq := mknode(nt);
                tp := tq
                end
            else begin
                tq^.tnext := mknode(nt);
                tq := tq^.tnext
                 end;
            case nt of
              nvarpar,
              nvalpar:
                begin
                tq^.tidl := pidlist(lidentifier);
                tq^.tattr := anone;
                checksymbol([scolon]);
                if nt = nvalpar then
                    nextsymbol([sid])
                else
                    nextsymbol([sid, sarray]);
                case currsym.st of
                  sid:
                    tq^.tbind :=
                        oldid(currsym.vid, lidentifier);
                  sarray:
                    tq^.tbind := pconform
                end;(* case *)
                nextsymbol([srpar, ssemic])
                end;
              nparproc:
                begin
                tq^.tparid := newid(currsym.vid);
                nextsymbol([ssemic, slpar, srpar]);
                if currsym.st = slpar then
                    begin
                    enterscope(nil);
                    tq^.tparparm := psubpar;
                    nextsymbol([ssemic, srpar]);
                    leavescope
                    end
                else
                    tq^.tparparm := nil;
                tq^.tpartyp := nil
                end;
              nparfunc:
                begin
                tq^.tparid := newid(currsym.vid);
                nextsymbol([scolon, slpar]);
                if currsym.st = slpar then
                    begin
                    enterscope(nil);
                    tq^.tparparm := psubpar;
                    nextsymbol([scolon]);
                    leavescope
                    end
                else
                    tq^.tparparm := nil;
                nextsymbol([sid]);
                tq^.tpartyp := oldid(currsym.vid, lidentifier);
                nextsymbol([srpar, ssemic])
                end
            end (* case *)
        until    currsym.st = srpar;
        psubpar := tp
    end;

    (*    Parse a (possibly labeled) statement.            *)
    function plabstmt;

    var    tp    : treeptr;

    begin
        nextsymbol([sid, sinteger, sif, swhile, srepeat, sfor, scase,
                  swith, sbegin, sgoto,
                    selse, ssemic, send, suntil]);
        if currsym.st = sinteger then
            begin
            tp := mknode(nlabstmt);
            tp^.tlabno := oldlbl(true);
            nextsymbol([scolon]);
            nextsymbol([sid, sif, swhile, srepeat, sfor, scase,
                  swith, sbegin, sgoto,
                    selse, ssemic, send, suntil]);
            tp^.tstmt := pstmt
            end
        else
            tp := pstmt;
        plabstmt := tp
    end;

    (*    Parse an unlabeled statement.                *)
    function pstmt;

    var    tp    : treeptr;

    begin
        case currsym.st of
          sid:
            tp := psimple;
          sif:
            tp := pif;
          swhile:
            tp := pwhile;
          srepeat:
            tp := prepeat;
          sfor:
            tp := pfor;
          scase:
            tp := pcase;
          swith:
            tp := pwith;
          sbegin:
            tp := pbegin(true);
          sgoto:
            tp := pgoto;
          send,
          selse,
          suntil,
          ssemic:
            tp := mknode(nempty);
        end;
        pstmt := tp
    end;

    (*    Parse an assignment or a procedure call.        *)
    function psimple;

    var    tq,
        tp    : treeptr;

    begin
        tp := pvariable(oldid(currsym.vid, lidentifier));
        if currsym.st = sassign then
            begin
            tq := mknode(nassign);
            tq^.tlhs := tp;
            tq^.trhs := pexpr(nil);
            tp := tq
            end;
        psimple := tp
    end;

    (*    Parse a varable-reference (or a subroutine-call).    *)
    function pvariable;

    var    tp,
        tq    : treeptr;

    begin
        nextsymbol([slpar, slbrack, sdot, sarrow,
            sassign, ssemic, scomma, scolon, sdotdot,
            splus, sminus, smul, sdiv, smod, squot,
            sand, sor, sinn, srpar, srbrack,
            sle, slt, seq, sge, sgt, sne,
            send, suntil, sthen, selse, sdo, sdownto, sto, sof]);
        if currsym.st in [slpar, slbrack, sdot, sarrow] then
            begin
            case currsym.st of
              slpar:
                begin
                tp := mknode(ncall);
                tp^.tcall := varptr;
                tq := nil;
                repeat
                    if tq = nil then
                        begin
                        tq := pexpr(nil);
                        tp^.taparm  := tq
                        end
                    else begin
                        tq^.tnext := pexpr(nil);
                        tq := tq^.tnext
                         end;
                until    currsym.st = srpar
                end;
              slbrack:
                begin
                tq := varptr;
                repeat
                    tp := mknode(nindex);
                    tp^.tvariable := tq;
                    tp^.toffset := pexpr(nil);
                    tq := tp
                until    currsym.st = srbrack
                end;
              sdot:
                begin
                tp := mknode(nselect);
                tp^.trecord := varptr;
                nextsymbol([sid]);
                tq := typeof(varptr);
                enterscope(tq^.trscope);
                tp^.tfield := oldid(currsym.vid, lfield);
                leavescope
                end;
              sarrow:
                begin
                tp := mknode(nderef);
                tp^.texps := varptr
                end
            end;(* case *)
            tp := pvariable(tp)
            end
        else begin
            tp := varptr;
            if tp^.tt = nid then
                begin
                tq := idup(tp);
                if tq <> nil then
                    if tq^.tt in [nfunc, nproc,
                            nparproc, nparfunc] then
                        begin
                        (* subroutine-call without
                           parameters *)
                        tp := mknode(ncall);
                        tp^.tcall := varptr;
                        tp^.taparm := nil
                        end
                end
             end;
        pvariable := tp
    end;

    (*    Parse an expression.                    *)
    function pexpr;

    var    tp,
        tq    : treeptr;
        nt    : treetyp;
        next    : boolean;

        function padjust(tu, tr : treeptr) : treeptr;
        begin
            if pprio[tu^.tt] >= pprio[tr^.tt] then
                begin
                if tr^.tt in [nnot, numinus, nuplus,
                            nset, nderef] then
                    tr^.texps := padjust(tu, tr^.texps)
                else
                    tr^.texpl := padjust(tu, tr^.texpl);
                padjust := tr
                end
            else begin
                if tu^.tt in [nnot, numinus, nuplus,
                            nset, nderef] then
                    tu^.texps := tr
                else
                    tu^.texpr := tr;
                padjust := tu
                 end
        end;

    begin
        nextsymbol([sid, schar, sinteger, sreal, sstring, snil,
                splus, sminus, snot, slpar, slbrack, srbrack]);
        next := true;
        case currsym.st of
          splus:
            begin
            tp := mknode(nuplus);
            tp^.texps := nil;
            tp := pexpr(tp);
            next := false
            end;
          sminus:
            begin
            tp := mknode(numinus);
            tp^.texps := nil;
            tp := pexpr(tp);
            next := false
            end;
          snot:
            begin
            tp := mknode(nnot);
            tp^.texps := nil;
            tp := pexpr(tp);
            next := false
            end;
          schar,
          sinteger,
          sreal,
          sstring:
            tp := mklit;
          snil:
            begin
            usenilp := true;
            tp := mknode(nnil);
            end;
          sid:
            begin
            tp := pvariable(oldid(currsym.vid, lidentifier));
            next := false
            end;
          slpar:
            begin
            tp := mknode(nuplus);
            tp^.texps := pexpr(nil)
            end;
          slbrack:
            begin
            usesets := true;
            tp := mknode(nset);
            tp^.texps := nil;
            tq := nil;
            repeat
                if tq = nil then
                    begin
                    tq := pexpr(nil);
                    tp^.texps := tq
                    end
                else begin
                    tq^.tnext := pexpr(nil);
                    tq := tq^.tnext
                     end
            until    currsym.st = srbrack;
            end;
          srbrack:
            begin
            tp := mknode(nempty);
            next := false
            end
        end;
        if next then
            nextsymbol([
                scolon, ssemic, scomma, sdotdot, srpar, srbrack,
                sle, slt, seq, sge, sgt, sne,
                splus, sminus, smul, sdiv, smod, squot,
                sand, sor, sinn,
                send, suntil, sthen, selse, sdo, sdownto, sto,
                sof, slpar, slbrack]);
        case currsym.st of
          sdotdot:
            nt := nrange;
          splus:
            nt := nplus;
          sminus:
            nt := nminus;
          smul:
            nt := nmul;
          sdiv:
            nt := ndiv;
          smod:
            nt := nmod;
          squot:
            begin
            defnams[dreal]^.lused := true;
            nt := nquot;
            end;
          sand:
            nt := nand;
          sor:
            nt := nor;
          sinn:
            begin
            nt := nin;
            usesets := true
            end;
          sle:
            nt := nle;
          slt:
            nt := nlt;
          seq:
            nt := neq;
          sge:
            nt := nge;
          sgt:
            nt := ngt;
          sne:
            nt := nne;
          scolon:
            nt := nformat;
          sid, schar, sinteger, sreal, sstring, snil,
          ssemic, scomma, slpar, slbrack, srpar, srbrack,
          send, suntil, sthen, selse, sdo, sdownto, sto, sof:
            nt := nnil
        end;(* case *)
        if nt in [nin .. nor, nand, nnot] then
            defnams[dboolean]^.lused := true;
        if nt <> nnil then
            begin
            (* binary operator *)
            tq := mknode(nt);
            tq^.texpl := tp;
            tq^.texpr := nil;
            tp := pexpr(tq)
            end;

        (* this statement yilds proper operator precedence *)
        if tnp <> nil then
            tp := padjust(tnp, tp);
        pexpr := tp
    end;

    (*    Parse a case-statement.                    *)
    function pcase;

    label    999;

    var    tp,
        tq,
        tv    : treeptr;

    begin
        tp := mknode(ncase);
        tp^.tcasxp := pexpr(nil);
        checksymbol([sof]);
        tq := nil;
        repeat
            if tq = nil then
                begin
                tq := mknode(nchoise);
                tp^.tcaslst := tq
                end
            else begin
                tq^.tnext := mknode(nchoise);
                tq := tq^.tnext
                 end;
            tv := nil;
            repeat
                nextsymbol([sid, sinteger, schar,
                        splus, sminus, send, sother]);
                if currsym.st in [send, sother] then
                    goto 999;
                if tv = nil then
                    begin
                    tv := pconstant(false);
                    tq^.tchocon := tv
                    end
                else begin
                    tv^.tnext := pconstant(false);
                    tv := tv^.tnext
                     end;
                nextsymbol([scomma, scolon])
            until    currsym.st = scolon;
            tq^.tchostmt := plabstmt
        until    currsym.st = send;
    999:
        if currsym.st = sother then
            begin
            nextsymbol([scolon, sid, sif, swhile, srepeat, sfor,
                    scase, swith, sbegin, sgoto,
                    selse, ssemic, send, suntil]);
            if currsym.st = scolon then
                nextsymbol([sid, sif, swhile, srepeat, sfor,
                    scase, swith, sbegin, sgoto,
                    selse, ssemic, send, suntil]);
            tp^.tcasother := pstmt
            end
        else begin
            tp^.tcasother := nil;
            usecase := true
             end;
        nextsymbol([ssemic, send, selse, suntil]);
        pcase := tp
    end;

    (*    Parse an if-statement.                    *)
    function pif;

    var    tp    : treeptr;

    begin
        tp := mknode(nif);
        tp^.tifxp := pexpr(nil);
        checksymbol([sthen]);
        tp^.tthen := plabstmt;
        if currsym.st = selse then
            tp^.telse := plabstmt
        else
            tp^.telse := nil;
        pif := tp;
    end;

    (*    Parse a while-statement.                *)
    function pwhile;

    var    tp    : treeptr;

    begin
        tp := mknode(nwhile);
        tp^.twhixp := pexpr(nil);
        checksymbol([sdo]);
        tp^.twhistmt := plabstmt;
        pwhile := tp;
    end;

    (*    Parse a repeat-statement.                *)
    function prepeat;

    var    tp,
        tq    : treeptr;

    begin
        tp := mknode(nrepeat);
        tq := nil;
        repeat
            if tq = nil then
                begin
                tq := plabstmt;
                tp^.treptstmt := tq
                end
            else begin
                tq^.tnext := plabstmt;
                tq := tq^.tnext
                 end;
            checksymbol([ssemic, suntil])
        until    currsym.st = suntil;
        tp^.treptxp := pexpr(nil);
        prepeat := tp
    end;

    (*    Parse a for-statement.                    *)
    function pfor;

    var    tp    : treeptr;

    begin
        tp := mknode(nfor);
        nextsymbol([sid]);
        tp^.tforid := oldid(currsym.vid, lidentifier);
        nextsymbol([sassign]);
        tp^.tfrom := pexpr(nil);
        checksymbol([sdownto, sto]);
        tp^.tincr := currsym.st = sto;
        tp^.tto := pexpr(nil);
        checksymbol([sdo]);
        tp^.tforstmt := plabstmt;
        pfor := tp
    end;

    (*    Parse a with-statement.                    *)
    function pwith;

    var    tp,
        tq    : treeptr;

    begin
        tp := mknode(nwith);
        tq := nil;
        repeat
            if tq = nil then
                begin
                tq := mknode(nwithvar);
                tp^.twithvar := tq
                end
            else begin
                tq^.tnext := mknode(nwithvar);
                tq := tq^.tnext
                 end;
            enterscope(nil);
            tq^.tenv := currscope;
            tq^.texpw := pexpr(nil);
            scopeup(tq^.texpw);
            checksymbol([scomma, sdo])
        until    currsym.st = sdo;
        tp^.twithstmt := plabstmt;
        tq := tp^.twithvar;
        while tq <> nil do
            begin
            leavescope;
            tq := tq^.tnext
            end;
        pwith := tp
    end;

    (*    Parse a goto-statement.                    *)
    function pgoto;

    var    tp    : treeptr;

    begin
        nextsymbol([sinteger]);
        tp := mknode(ngoto);
        tp^.tlabel := oldlbl(false);
        nextsymbol([ssemic, send, suntil, selse]);
        pgoto := tp
    end;

    (*    Parse a begin-statement.                *)
    function pbegin;

    var    tp,
        tq    : treeptr;

    begin
        tq := nil;
        repeat
            if tq = nil then
                begin
                tq := plabstmt;
                tp := tq
                end
            else begin
                tq^.tnext := plabstmt;
                tq := tq^.tnext
                 end
        until    currsym.st = send;
        if retain then
            begin
            tq := mknode(nbegin);
            tq^.tbegin := tp;
            tp := tq
            end;
        nextsymbol([send, selse, suntil, sdot, ssemic]);
        pbegin := tp
    end;

begin    (* parse *)
    nextsymbol([spgm, sconst, stype, svar, sproc, sfunc]);
    if currsym.st = spgm then
        top := pprogram
    else
        top := pmodule;
    nextsymbol([seof]);
end;    (* parse *)

(*    Compute value for a node (which must be some kind of constant).    *)
function cvalof(tp : treeptr) : integer;

var    v    : integer;
    tq    : treeptr;

begin
    case tp^.tt of
      nuplus:
        cvalof := cvalof(tp^.texps);
      numinus:
        cvalof := - cvalof(tp^.texps);
      nnot:
        cvalof := 1 - cvalof(tp^.texps);
      nid:
        begin
        tq := idup(tp);
        if tq = nil then
            fatal(etree);
        tp := tp^.tsym^.lsymdecl;
        case tq^.tt of
          nscalar:
            begin
            v := 0;
            tq := tq^.tscalid;
            while tq <> nil do
                if tq = tp then
                    tq := nil
                else begin
                    v := v + 1;
                    tq := tq^.tnext
                     end;
            cvalof := v
            end;
          nconst:
            cvalof := cvalof(tq^.tbind);
        end;(* case *)
        end;
      ninteger:
        cvalof := tp^.tsym^.linum;
      nchar:
        cvalof := ord(tp^.tsym^.lchar);
    end (* case *)
end;    (* cvalof *)

(*    Compute lower value of subrange or scalar type.            *)
function clower(tp : treeptr) : integer;

var    tq    : treeptr;

begin
    tq := typeof(tp);
    if tq^.tt = nscalar then
        clower := scalbase
    else if tq^.tt = nsubrange then
        if tq^.tup^.tt = nconfarr then
            clower := 0
        else
            clower := cvalof(tq^.tlo)
    else if tq = typnods[tchar] then
        clower := 0
    else if tq = typnods[tinteger] then
        clower := -maxint
    else
        fatal(etree)
end;    (* clower *)

(*    Compute upper value of subrange or scalar type.            *)
function cupper(tp : treeptr) : integer;

var    tq    : treeptr;
    i    : integer;

begin
    tq := typeof(tp);
    if tq^.tt = nscalar then
        begin
        tq := tq^.tscalid;
        i := scalbase;
        while tq^.tnext <> nil do
            begin
            i := i + 1;
            tq := tq^.tnext
            end;
        cupper := i
        end
    else if tq^.tt = nsubrange then
        if tq^.tup^.tt = nconfarr then
            fatal(euprconf)
        else
            cupper := cvalof(tq^.thi)
    else if tq = typnods[tchar] then
        cupper := maxchar
    else if tq = typnods[tinteger] then
        cupper := maxint
    else
        fatal(etree)
end;    (* cupper *)

(*    Compute the number of elements in a subrange.            *)
function crange(tp : treeptr) : integer;

begin
    crange := cupper(tp) - clower(tp) + 1
end;

(*    Return number of words uset to store a set.            *)
function csetwords(i : integer) : integer;

begin
    i := (i+(setbits)) div (setbits+1);
    if i > maxsetrange then
        error(esetsize);
    csetwords := i
end;

(*    Return number of words uset to store a set.            *)
function csetsize(tp : treeptr) : integer;

var    tq    : treeptr;
    i    : integer;

begin
    tq := typeof(tp^.tof);
    i := clower(tq);
    (* bits in sets are always numbered from 0, so we (arbitrarily)
       decide that the base must be in the first 6 words to avoid
       unnecessary waste of space *)
    if (i < 0) or (i >= 6 * (setbits+1))  then
        error(esetbase);
    csetsize := csetwords(crange(tq)) + 1
end;

(*    Determine if tp is declared in the procedure it is used in.    *)
function islocal(tp : treeptr) : boolean;

var    tq    : treeptr;

begin
    tq := tp^.tsym^.lsymdecl;
    while not (tq^.tt in [nproc, nfunc, npgm]) do
        tq := tq^.tup;
    while not (tp^.tt in [nproc, nfunc, npgm]) do
        tp := tp^.tup;
    islocal := tp = tq
end;

(*    Perform necessary transformations on tree and identifiers    *)
(*    before generating code.                        *)
procedure transform;


    (*    Rename function when used as a variable.        *)
    procedure renamf(tp : treeptr);

    var    ip, iq    : symptr;
        tq, tv    : treeptr;

        (*    This procedure recursively descends the tree    *)
        (*    and replaces function-assignments with variable    *)
        (*    assignments.                    *)
        procedure crtnvar(tp : treeptr);

        begin
            while tp <> nil do
                begin
                case tp^.tt of
                  npgm:
                    crtnvar(tp^.tsubsub);
                  nfunc,
                  nproc:
                    begin
                    crtnvar(tp^.tsubsub);
                    crtnvar(tp^.tsubstmt)
                    end;
                  nbegin:
                    crtnvar(tp^.tbegin);
                  nif:
                    begin
                    crtnvar(tp^.tthen);
                    crtnvar(tp^.telse)
                    end;
                  nwhile:
                    crtnvar(tp^.twhistmt);
                  nrepeat:
                    crtnvar(tp^.treptstmt);
                  nfor:
                    crtnvar(tp^.tforstmt);
                  ncase:
                    begin
                    crtnvar(tp^.tcaslst);
                    crtnvar(tp^.tcasother)
                    end;
                  nchoise:
                    crtnvar(tp^.tchostmt);
                  nwith:
                    crtnvar(tp^.twithstmt);
                  nlabstmt:
                    crtnvar(tp^.tstmt);
                  nassign:
                    begin
                    (* revoke calls in assignment lhs, (mis-
                       parsed due to ambiguous syntax) *)
                    if tp^.tlhs^.tt = ncall then
                        begin
                        tp^.tlhs := tp^.tlhs^.tcall;
                        tp^.tlhs^.tup := tp
                        end;
                    (* function name -> variable name *)
                    tv := tp^.tlhs;
                    if tv^.tt = nid then
                        if tv^.tsym = ip then
                            tv^.tsym := iq
                    end;
                  nbreak,
                  npush,
                  npop,
                  ngoto,
                  nempty,
                  ncall:
                    (* no op *)
                end;(* case *)
                tp := tp^.tnext
                end
        end;

    begin    (* renamf *)
        while tp <> nil do
            begin
            case tp^.tt of
              npgm,
              nproc:
                renamf(tp^.tsubsub);
              nfunc:
                begin
                (* create a variable to hold return value *)
                tq := mknode(nvar);
                tq^.tattr := aregister;
                tq^.tup := tp;
                tq^.tidl := newid(mkvariable('R'));
                tq^.tidl^.tup := tq;
                tq^.tbind := tp^.tfuntyp;
                (* put it FIRST among variables, see esubr() *)
                tq^.tnext := tp^.tsubvar;
                tp^.tsubvar := tq;

                iq := tq^.tidl^.tsym;
                ip := tp^.tsubid^.tsym;
                crtnvar(tp^.tsubsub);
                crtnvar(tp^.tsubstmt);
                (* process inner functions *)
                renamf(tp^.tsubsub)
                end;
            end;(* case *)
            tp := tp^.tnext
            end
    end;    (* renamf *)

    (*    This procedure rearranges the tree such that multiple    *)
    (*    vardeclarations don't have (structured) types attached    *)
    (*    to them. If such a declararation is found, a new name    *)
    (*    is created and the type is moved to the type section.    *)
    procedure extract(tp : treeptr);

    var    vp    : treeptr;

        (*    Create a declaration for tp, enter in pp type-    *)
        (*    list and return an identifier referencing it.    *)
        function xtrit(tp, pp : treeptr; last : boolean) : treeptr;

        var    np, rp    : treeptr;
            ip    : idptr;

        begin
            (* create new declaration *)
            np := mknode(ntype);
            ip := mkvariable('T');
            np^.tidl := newid(ip);
            np^.tidl^.tup := np;

            (* create substitute id *)
            rp := oldid(ip, lidentifier);
            rp^.tup := tp^.tup;
            rp^.tnext := tp^.tnext;

            (* steal type description *)
            np^.tbind := tp;
            tp^.tup := np;
            tp^.tnext := nil;

            (* add new declaration to tree *)
            np^.tup := pp;
            if last and (pp^.tsubtype <> nil) then
                begin
                pp := pp^.tsubtype;
                while pp^.tnext <> nil do
                    pp := pp^.tnext;
                pp^.tnext := np
                end
            else begin
                np^.tnext := pp^.tsubtype;
                pp^.tsubtype := np;
                end;

            xtrit := rp;
        end;

        (*    Extract anonymous enumeration types.        *)
        function xtrenum(tp, pp : treeptr) : treeptr;

            (*    Name record-types referenced by ptrs.    *)
            procedure nametype(tp : treeptr);

            begin
                tp := typeof(tp);
                if tp^.tt = nrecord then
                    if tp^.tuid = nil then
                        tp^.tuid := mkvariable('S');
            end;

        begin
            if tp <> nil then
                begin
                case tp^.tt of
                  nfield,
                  ntype,
                  nvar:
                    tp^.tbind :=
                        xtrenum(tp^.tbind, pp);

                  nscalar:
                    if tp^.tup^.tt <> ntype then
                        tp := xtrit(tp, pp, false);

                  narray:
                    begin
                    tp^.taindx := xtrenum(tp^.taindx, pp);
                    tp^.taelem := xtrenum(tp^.taelem, pp);
                    end;
                  nrecord:
                    begin
                    tp^.tflist := xtrenum(tp^.tflist, pp);
                    tp^.tvlist := xtrenum(tp^.tvlist, pp);
                    end;
                  nvariant:
                    tp^.tvrnt := xtrenum(tp^.tvrnt, pp);
                  nfileof:
                    tp^.tof := xtrenum(tp^.tof, pp);

                  nptr:
                    nametype(tp^.tptrid);

                  nid,
                  nsubrange,
                  npredef,
                  nempty,
                  nsetof:
                    (* no op *)
                end;(* case *)
                tp^.tnext := xtrenum(tp^.tnext, pp)
                end;
            xtrenum := tp
        end;

    begin    (* extract *)
        while tp <> nil do
            begin
            (* tp points to a program/procedure/function node *)
            tp^.tsubtype := xtrenum(tp^.tsubtype, tp);
            tp^.tsubvar := xtrenum(tp^.tsubvar, tp);
            vp := tp^.tsubvar;
            while vp <> nil do
                begin
                (* variables of structured unnamed types *)
                if vp^.tbind^.tt in [nscalar, narray,
                            nrecord, nfileof] then
                    vp^.tbind := xtrit(vp^.tbind, tp, true);
                vp := vp^.tnext
                end;
            extract(tp^.tsubsub);
            tp := tp^.tnext
            end
    end;    (* extract *)

    (*    This procedure moves all local constants and types    *)
    (*    used in nested procedures to the outermost declaration    *)
    (*    level so that nested procedures may be extracted.    *)
    procedure global(tp, dp : treeptr; depend : boolean);

    label    555;

    var    ip    : treeptr;
        dep    : boolean;

        (*    Mark all declared identifiers as unused.    *)
        procedure markdecl(xp : treeptr);

        begin
            while xp <> nil do
                begin
                case xp^.tt of
                  nid:
                    xp^.tsym^.lused := false;
                  nconst:
                    markdecl(xp^.tidl);
                  ntype,
                  nvar,
                  nvalpar,
                  nvarpar,
                  nfield:
                    begin
                    markdecl(xp^.tidl);
                    if xp^.tbind^.tt <> nid then
                        markdecl(xp^.tbind)
                    end;
                  nscalar:
                    markdecl(xp^.tscalid);
                  nrecord:
                    begin
                    markdecl(xp^.tflist);
                    markdecl(xp^.tvlist)
                    end;
                  nvariant:
                    markdecl(xp^.tvrnt);
                  nconfarr:
                    if xp^.tcelem^.tt <> nid then
                        markdecl(xp^.tcelem);
                  narray:
                    if xp^.taelem^.tt <> nid then
                        markdecl(xp^.taelem);
                  nsetof,
                  nfileof:
                    if xp^.tof^.tt <> nid then
                        markdecl(xp^.tof);
                  nparproc,
                  nparfunc:
                    markdecl(xp^.tparid);
                  nptr,
                  nsubrange:
                    (* no op *)
                end;(* case *)
                xp := xp^.tnext
                end
        end;    (* markdecl *)

        (*    Move all marked declarations to global scope.    *)
        function movedecl(tp : treeptr) : treeptr;

        var    ip, np    : treeptr;
            sp    : symptr;
            move    : boolean;

        begin
            if tp <> nil then
                begin
                move := false;
                case tp^.tt of
                  nconst,
                  ntype:
                    ip := tp^.tidl
                end;(* case *)
                while ip <> nil do
                    begin
                    if ip^.tsym^.lused then
                        begin
                        move := true;
                        sp := ip^.tsym;
                        if sp^.lid^.inref > 1 then
                          begin
                            sp^.lid :=
                            mkrename( 'M', sp^.lid);
                            sp^.lid^.inref :=
                                sp^.lid^.inref - 1
                          end;
                        ip := nil
                        end
                    else
                        ip := ip^.tnext
                    end;
                if move then
                    begin
                    np := tp^.tnext;
                    tp^.tnext := nil;
                    ip := tp;
                    while ip^.tt <> npgm do
                        ip := ip^.tup;
                    tp^.tup := ip;
                    case tp^.tt of
                      nconst:
                        begin
                        if ip^.tsubconst = nil then
                            ip^.tsubconst := tp
                        else begin
                            ip := ip^.tsubconst;
                            while ip^.tnext <> nil
                                do ip := ip^.tnext;
                            ip^.tnext := tp
                             end
                        end;
                      ntype:
                        begin
                        if ip^.tsubtype = nil then
                            ip^.tsubtype := tp
                        else begin
                            ip := ip^.tsubtype;
                            while ip^.tnext <> nil
                                do ip := ip^.tnext;
                            ip^.tnext := tp
                             end
                        end
                    end;(* case *)
                    (* tp is moved, drop it and process
                       remainder of declarationlist *)
                    tp := movedecl(np)
                    end
                else
                    tp^.tnext := movedecl(tp^.tnext)
                end;
            movedecl := tp
        end;    (* movedecl *)

        (*    This procedure lifts out variables/parameters    *)
        (*    used in nested procedures/functions.        *)
        procedure movevars(tp, vp : treeptr);

        label    555;

        var    ep, dp, np    : treeptr;
            ip        : idptr;
            sp        : symptr;

            (*    Move a variable    declaration to global    *)
            (*    var declaration lists.            *)
            procedure moveglob(tp, dp : treeptr);

            begin
                while tp^.tt <> npgm do
                    tp := tp^.tup;
                dp^.tup := tp;
                dp^.tnext := tp^.tsubvar;
                tp^.tsubvar := dp
            end;

            (*    Create nodes for saving a global    *)
            (*    pointer variable.            *)
            function stackop(decl, glob, loc : treeptr) : treeptr;

            var    op, ip, dp, tp    : treeptr;

            begin
                (* create a new variable to hold old value
                   of the global variable during a call *)
                ip := newid(mkvariable('F'));
                case vp^.tt of
                  nvarpar,
                  nvalpar,
                  nvar:
                    begin
                    dp := mknode(nvarpar);
                    dp^.tattr := areference;
                    dp^.tidl := ip;
                    (* use same type as the global var *)
                    dp^.tbind := decl^.tbind
                    end;
                  nparproc,
                  nparfunc:
                    begin
                    dp := mknode(vp^.tt);
                    dp^.tparid := ip;
                    dp^.tparparm := nil;
                    dp^.tpartyp := vp^.tpartyp
                    end
                end;(* case *)
                ip^.tup := dp;

                (* add variable to declarationlists *)
                tp := decl;
                while not (tp^.tt in [nproc, nfunc, npgm]) do
                    tp := tp^.tup;
                dp^.tup := tp;
                if tp^.tsubvar = nil then
                    tp^.tsubvar := dp
                else begin
                    tp := tp^.tsubvar;
                    while tp^.tnext <> nil do
                        tp := tp^.tnext;
                    tp^.tnext := dp
                     end;
                dp^.tnext := nil;

                (* create an assignment saving value *)
                op := mknode(npush);
                op^.tglob := glob;
                op^.tloc := loc;
                op^.ttmp := ip;
                stackop := op
            end;

            (*    Take a "push" node, create "pop" node    *)
            (*    and add both to tree.            *)
            procedure addcode(tp, push : treeptr);

            var    pop    : treeptr;

            begin
                pop := mknode(npop);
                (* share variables with "push"-node *)
                pop^.tglob := push^.tglob;
                pop^.ttmp := push^.ttmp;
                pop^.tloc := nil;

                (* add npush to head of statement list *)
                push^.tnext := tp^.tsubstmt;
                tp^.tsubstmt := push;
                push^.tup := tp;

                (* add npop to end of statement list *)
                while push^.tnext <> nil do
                    push := push^.tnext;
                push^.tnext := pop;
                pop^.tup := tp
            end;

        begin    (* movevars *)
            while vp <> nil do
                begin
                case vp^.tt of
                  nvar,
                  nvalpar,
                  nvarpar:
                    dp := vp^.tidl;
                  nparproc,
                  nparfunc:
                    begin
                    dp := vp^.tparid;
                    if dp^.tsym^.lused then
                        begin
                        (* create a var declaration *)
                        ep := mknode(vp^.tt);
                        ep^.tparparm := nil;
                        ep^.tpartyp := vp^.tpartyp;
                        np := newid(mkrename('G',
                                dp^.tsym^.lid));
                        ep^.tparid := np;
                        np^.tup := ep;
                        (* swap id's and symbols *)
                        sp := np^.tsym;
                        ip := sp^.lid;
                        np^.tsym^.lid := dp^.tsym^.lid;
                        dp^.tsym^.lid := ip;
                        np^.tsym := dp^.tsym;
                        dp^.tsym := sp;
                        np^.tsym^.lsymdecl := np;
                        dp^.tsym^.lsymdecl := dp;
                        (* make declaration global *)
                        moveglob(tp, ep);
                        (* add save/restore-code *)
                        addcode(tp, stackop(vp, np, dp))
                        end;
                    goto 555
                    end
                end;(* case *)
                while dp <> nil do
                    begin
                    if dp^.tsym^.lused then
                        begin
                        (* create a varpar declaration,
                           (nvarpar will cause emit to
                           treat the new identifier
                           as a pointer) *)
                        ep := mknode(nvarpar);
                        ep^.tattr := areference;
                        np := newid(mkrename('G',
                                dp^.tsym^.lid));
                        ep^.tidl := np;
                        np^.tup := ep;
                        ep^.tbind := vp^.tbind;
                        if ep^.tbind^.tt = nid then
                            ep^.tbind^.tsym^.lused
                                := true;
                        (* swap id's and symbols *)
                        sp := np^.tsym;
                        ip := sp^.lid;
                        np^.tsym^.lid := dp^.tsym^.lid;
                        dp^.tsym^.lid := ip;
                        np^.tsym := dp^.tsym;
                        dp^.tsym := sp;
                        np^.tsym^.lsymdecl := np;
                        dp^.tsym^.lsymdecl := dp;
                        (* note that dp is referenced *)
                        dp^.tup^.tattr := aextern;
                        (* make declaration global *)
                        moveglob(tp, ep);
                        (* add save/restore-code *)
                        addcode(tp, stackop(vp, np, dp))
                        end;
                    dp := dp^.tnext
                    end;
            555:
                vp := vp^.tnext
                end
        end;    (* movevars *)

        (*    Break out a local variable and set the register    *)
        (*    attribute.                    *)
        procedure registervar(tp : treeptr);

        var    vp, xp    : treeptr;

        begin
            vp := idup(tp);
            tp := tp^.tsym^.lsymdecl;
            (* vp points to nvar node *)
            if (vp^.tidl <> tp) or (tp^.tnext <> nil) then
                begin
                (* tp is not alone in list of identifiers,
                   create a new nvar-node and hook up tp *)
                xp := mknode(nvar);
                xp^.tattr := anone;
                xp^.tidl := tp;
                tp^.tup := xp;
                (* enter new nvar node among declarations *)
                xp^.tup := vp^.tup;
                xp^.tbind := vp^.tbind; (* borrow type *)
                xp^.tnext := vp^.tnext;
                vp^.tnext := xp;
                (* break tp out of list of identifiers *)
                if vp^.tidl = tp then
                    vp^.tidl := tp^.tnext
                else begin
                    vp := vp^.tidl;
                    while vp^.tnext <> tp do
                        vp := vp^.tnext;
                    vp^.tnext := tp^.tnext
                     end;
                tp^.tnext := nil
                end;
            (* tp is alone in this declaration, set attribute *)
            if tp^.tup^.tattr = anone then
                tp^.tup^.tattr := aregister
        end;    (* registervar *)

        (*    Check static declarationlevel for a label    *)
        (*    used in a non-local goto.            *)
        procedure cklevel(tp : treeptr);

        begin
            tp := tp^.tsym^.lsymdecl;
            while not(tp^.tt in [npgm, nproc, nfunc]) do
                tp := tp^.tup;
            if tp^.tstat > maxlevel then
                maxlevel := tp^.tstat
        end;

    begin    (* global *)
        while tp <> nil do
            begin
            case tp^.tt of
              nproc,
              nfunc:
                begin
                (* procid/parameters/const/type/var not used *)
                markdecl(tp^.tsubid);
                markdecl(tp^.tsubpar);
                markdecl(tp^.tsubconst);
                markdecl(tp^.tsubtype);
                markdecl(tp^.tsubvar);

                (* mark those used in nested subroutines *)
                global(tp^.tsubsub, tp, false);

                (* move out variables used in inner scope *)
                movevars(tp, tp^.tsubpar);
                movevars(tp, tp^.tsubvar);
                (* move out const/type used in inner scope *)
                tp^.tsubtype := movedecl(tp^.tsubtype);
                tp^.tsubconst := movedecl(tp^.tsubconst);

                (* mark identifiers used in this subroutine *)
                global(tp^.tsubstmt, tp, true);
                global(tp^.tsubpar, tp, false);
                global(tp^.tsubvar, tp, false);
                global(tp^.tsubtype, tp, false);
                global(tp^.tfuntyp, tp, false);
                end;

              npgm:
                begin
                markdecl(tp^.tsubconst);
                markdecl(tp^.tsubtype);
                markdecl(tp^.tsubvar);
                global(tp^.tsubsub, tp, false);
                global(tp^.tsubstmt, tp, true)
                end;

              nconst,
              ntype,
              nvar,
              nfield,
              nvalpar,
              nvarpar:
                begin
                ip := tp^.tidl;
                dep := depend;
                while (ip <> nil) and not dep do
                    begin
                    (* for all used identifiers, propagate
                       the use to their bindings *)
                    if ip^.tsym^.lused then
                        dep := true;
                    ip := ip^.tnext
                    end;
                global(tp^.tbind, dp, dep);
                end;
              nparproc,
              nparfunc:
                begin
                global(tp^.tparparm, dp, depend);
                global(tp^.tpartyp, dp, depend)
                end;
              nsubrange:
                begin
                global(tp^.tlo, dp, depend);
                global(tp^.thi, dp, depend)
                end;
              nvariant:
                begin
                global(tp^.tselct, dp, depend);
                global(tp^.tvrnt, dp, depend)
                end;
              nrecord:
                begin
                global(tp^.tflist, dp, depend);
                global(tp^.tvlist, dp, depend)
                end;
              nconfarr:
                begin
                global(tp^.tcindx, dp, depend);
                global(tp^.tcelem, dp, depend)
                end;
              narray:
                begin
                global(tp^.taindx, dp, depend);
                global(tp^.taelem, dp, depend)
                end;
              nfileof,
              nsetof:
                global(tp^.tof, dp, depend);
              nptr:
                global(tp^.tptrid, dp, depend);
              nscalar:
                global(tp^.tscalid, dp, depend);
              nbegin:
                global(tp^.tbegin, dp, depend);
              nif:
                begin
                global(tp^.tifxp, dp, depend);
                global(tp^.tthen, dp, depend);
                global(tp^.telse, dp, depend)
                end;
              nwhile:
                begin
                global(tp^.twhixp, dp, depend);
                global(tp^.twhistmt, dp, depend)
                end;
              nrepeat:
                begin
                global(tp^.treptstmt, dp, depend);
                global(tp^.treptxp, dp, depend)
                end;
              nfor:
                begin
                ip := idup(tp^.tforid);
                if ip^.tup^.tt in [nproc, nfunc] then
                    registervar(tp^.tforid);
                global(tp^.tforid, dp, depend);
                global(tp^.tfrom, dp, depend);
                global(tp^.tto, dp, depend);
                global(tp^.tforstmt, dp, depend)
                end;
              ncase:
                begin
                global(tp^.tcasxp, dp, depend);
                global(tp^.tcaslst, dp, depend);
                global(tp^.tcasother, dp, depend)
                end;
              nchoise:
                begin
                global(tp^.tchocon, dp, depend);
                global(tp^.tchostmt, dp, depend);
                end;
              nwith:
                begin
                global(tp^.twithvar, dp, depend);
                global(tp^.twithstmt, dp, depend)
                end;
              nwithvar:
                begin
                ip := typeof(tp^.texpw);
                if ip^.tuid = nil then
                    ip^.tuid := mkvariable('S');
                global(tp^.texpw, dp, depend);
                end;
              nlabstmt:
                global(tp^.tstmt, dp, depend);
              neq, nne, nlt, nle, ngt, nge:
                begin
                global(tp^.texpl, dp, depend);
                global(tp^.texpr, dp, depend);
                ip := typeof(tp^.texpl);
                if (ip = typnods[tstring]) or
                            (ip^.tt = narray) then
                    usecomp := true;
                ip := typeof(tp^.texpr);
                if (ip = typnods[tstring]) or
                            (ip^.tt = narray) then
                    usecomp := true
                end;
              nin, nor, nplus, nminus,
              nand, nmul, ndiv, nmod, nquot,
              nformat, nrange:
                begin
                global(tp^.texpl, dp, depend);
                global(tp^.texpr, dp, depend)
                end;

              nassign:
                begin
                global(tp^.tlhs, dp, depend);
                global(tp^.trhs, dp, depend)
                end;

              nnot,
              numinus,
              nuplus,
              nderef:
                global(tp^.texps, dp, depend);
              nset:
                global(tp^.texps, dp, depend);
              nindex:
                begin
                global(tp^.tvariable, dp, depend);
                global(tp^.toffset, dp, depend)
                end;
              nselect:
                global(tp^.trecord, dp, depend);
              ncall:
                begin
                global(tp^.tcall, dp, depend);
                global(tp^.taparm, dp, depend)
                end;
              nid:
                begin
                (* find declaration point *)
                ip := idup(tp);
                if ip = nil then
                    goto 555;
                (* ip points to nconst/ntype/nvar/nproc/nfunc/
                   nvalpar/nvarpar/nparproc or nparfunc node,
                   move to beginning of enclosing scope *)
                repeat
                    ip := ip^.tup;
                    if ip = nil then
                        goto 555
                    (* stop only for locally declared items,
                       for global or predefined identifiers
                       we will have gone to label 555 *)
                until    ip^.tt in [npgm, nproc, nfunc];
                if dp = ip then
                    begin
                    (* identifier used here, mark it used *)
                    if depend then
                        tp^.tsym^.lused := true
                    end
                else begin
                    (* identifier declared in enclosing
                       scope, mark it used *)
                    tp^.tsym^.lused := true
                     end;
            555:
                end;
              ngoto:
                if not islocal(tp^.tlabel) then
                    begin
                    tp^.tlabel^.tsym^.lgo := true;
                    usejmps := true;
                    cklevel(tp^.tlabel)
                    end;

              nbreak,
              npush,
              npop,
              npredef,
              nempty,
              nchar,
              ninteger,
              nreal,
              nstring,
              nnil:
            end;(* case *)
            tp := tp^.tnext
            end
    end;    (* global *)

    (*    Rename identifiers identical to C keywords.        *)
    procedure renamc;

    var    ip    : idptr;
        cn    : cnames;

    begin
        (* rename identifiers that mustn't be redefined
           if C and Pascal semantix are to be preserved *)
        for cn := cabort to cwrite do
            begin
            ip := mkrename('C', ctable[cn]);
            ctable[cn]^.istr := ip^.istr
            end
    end;

    (*    Rename subroutines declared in other subroutines such    *)
    (*    that they can be moved to a global scope without name-    *)
    (*    clashes.                        *)
    procedure renamp(tp : treeptr; on : boolean);

    var    sp    : symptr;

    begin
        (* tp points to subroutine-list *)
        while tp <> nil do
            begin
            renamp(tp^.tsubsub, true);
            if on and (tp^.tsubstmt <> nil) then
                begin
                (* change name of subroutine by prefixing
                   a unique name *)
                sp := tp^.tsubid^.tsym;
                if sp^.lid^.inref > 1 then
                    begin
                    sp^.lid := mkrename('P', sp^.lid);
                    sp^.lid^.inref := sp^.lid^.inref - 1
                    end
                end;
            tp := tp^.tnext
            end
    end;

    (*    Add initialization-code for file-variables.        *)
    procedure initcode(tp : treeptr);

    var    ti, tq, tu, tv    : treeptr;

        (*    Determine if a type contains a file.        *)
        function filevar(tp : treeptr) : boolean;

        var    fv    : boolean;
            tq    : treeptr;

        begin
            case tp^.tt of
              npredef:
                fv := tp = typnods[ttext];
              nfileof:
                fv := true;
              nconfarr:
                fv := filevar(typeof(tp^.tcelem));
              narray:
                fv := filevar(typeof(tp^.taelem));
              nrecord:
                begin
                fv := false;
                tq := tp^.tvlist;
                while tq <> nil do
                    begin
                    if filevar(tq^.tvrnt) then
                        error(evrntfile);
                    tq := tq^.tnext
                    end;
                tq := tp^.tflist;
                while tq <> nil do
                    begin
                    if filevar(typeof(tq^.tbind)) then
                        begin
                        fv := true;
                        tq := nil
                        end
                    else
                        tq := tq^.tnext
                    end
                end;
              nptr:
                begin
                fv := false;
                if not tp^.tptrflag then
                    begin
                    tp^.tptrflag := true;
                    if filevar(typeof(tp^.tptrid)) then
                        error(evarfile);
                    tp^.tptrflag := false
                    end
                end;
              nsubrange,
              nscalar,
              nsetof:
                fv := false
            end;
            filevar := fv
        end;

        (*    Create code for initialization of files.    *)
        function fileinit(ti, tq : treeptr; opn : boolean) : treeptr;

        var    tx, ty, tz    : treeptr;

        begin
            (* create 1 statement initializing "ti" *)
            case tq^.tt of
              narray:
                begin
                (* create declaration for a loopvariable *)
                tz := newid(mkvariable('I'));
                ty := mknode(nvar);
                ty^.tattr := aregister;
                ty^.tidl := tz;
                ty^.tbind := typeof(tq^.taindx);
                tz := tq;
                while not(tz^.tt in [nproc, nfunc, npgm]) do
                    tz := tz^.tup;
                linkup(tz, ty);
                if tz^.tsubvar = nil then
                    tz^.tsubvar := ty
                else begin
                    tz := tz^.tsubvar;
                    while tz^.tnext <> nil do
                        tz := tz^.tnext;
                    tz^.tnext := ty
                     end;
                ty := ty^.tidl;
                (* create a loop initializing tq *)
                tz := mknode(nindex);
                tz^.tvariable := ti;
                tz^.toffset := ty;
                tz := fileinit(tz, tq^.taelem, opn);
                tx := mknode(nfor);
                tx^.tforid := ty;
                ty := typeof(tq^.taindx);
                if ty^.tt = nsubrange then
                    begin
                    tx^.tfrom := ty^.tlo;